(* LALR(1) table generator
	Copyright (C) 2008, 2009 Yuta Tomino.
	"caper" Copyright (C) 2006-2008 Naoyuki Hirayama.
	All Rights Reserved. *)

module type TokenType = sig
	type t;;
	val compare: t -> t -> int;;
	val eof: t;;
	val pp_pattern: quali:bool -> paren:bool -> Format.formatter -> t -> unit;;
end;;

module type SemanticActionType = sig
	type t;;
	val compare: t -> t -> int;;
	val is_error: t -> bool;;
	val pp: Format.formatter -> t -> unit;;
end;;

module Make (Token: TokenType) (SemanticAction: SemanticActionType) = struct
	
	(* token *)
	
	module TokenSet = Set.Make (Token);;
	
	module TokenMap = struct
		include Map.Make (Token);;
		let find_or ~not_found k m = (
			try find k m with Not_found -> not_found
		);;
	end;;
	
	(* action *)
	
	type action =
		| Shift of int (* dest state index *)
		| Reduce of int * SemanticAction.t * int (* pop, semantic action, nonterminal index *)
		| ErrorShiftTerminal of TokenSet.t * int (* token set, dest state index *)
		| ErrorShiftNonterminal of TokenSet.t * SemanticAction.t * bool * int (* token set, semantic action, optional, dest state index *)
		| ErrorReduce of int * SemanticAction.t * int (* pop, semantic action, nonterminal index *)
		| Accept;;
	
	module Action = struct
		
		type t = action;;
		
		let compare_g ~(with_hint: bool) (x: t) (y: t) = (
			let index (x: t): int = (
				begin match x with
				| Shift _ -> 0
				| Reduce _ -> 1
				| ErrorShiftTerminal _ -> 2
				| ErrorShiftNonterminal _ -> 3
				| ErrorReduce _ -> 4
				| Accept -> 5
				end
			) in
			let r = index x - index y in
			if r = 0 then (
				begin match x with
				| Shift xd ->
					begin match y with
					| Shift yd -> Pervasives.compare xd yd
					| _ -> assert false
					end
				| Reduce (xp, xa, xn) ->
					begin match y with
					| Reduce (yp, ya, yn) ->
						let r = Pervasives.compare xp yp in
						if r <> 0 then r else
						let r = Pervasives.compare xn yn in
						if r <> 0 then r else
						SemanticAction.compare xa ya
					| _ -> assert false
					end
				| ErrorShiftTerminal (xs, xd) ->
					begin match y with
					| ErrorShiftTerminal (ys, yd) ->
						let r = Pervasives.compare xd yd in
						if r <> 0 || not with_hint then r else
						TokenSet.compare xs ys
					| _ -> assert false
					end
				| ErrorShiftNonterminal (xs, xa, xo, xd) ->
					begin match y with
					| ErrorShiftNonterminal (ys, ya, yo, yd) ->
						let r = Pervasives.compare xd yd in
						if r <> 0 then r else
						let r = Pervasives.compare xo yo in
						if r <> 0 then r else
						let r = SemanticAction.compare xa ya in
						if r <> 0 || not with_hint then r else
						TokenSet.compare xs ys
					| _ -> assert false
					end
				| ErrorReduce (xp, xa, xn) ->
					begin match y with
					| ErrorReduce (yp, ya, yn) ->
						let r = Pervasives.compare xp yp in
						if r <> 0 then r else
						let r = Pervasives.compare xn yn in
						if r <> 0 then r else
						SemanticAction.compare xa ya
					| _ -> assert false
					end
				| Accept -> 0
				end
			) else (
				r
			)
		);;
		
		let compare = compare_g ~with_hint:true;;
		
	end;;
	
	(* symbol *)
	
	type symbol =
		| Epsilon
		| Terminal of Token.t
		| Nonterminal of int (* nonterminal index *)
		| Dummy;;
	
	module Symbol = struct
		
		type t = symbol;;
		
		let compare (x: t) (y: t): int = (
			let index (s: t): int = (
				begin match s with
				| Epsilon -> 0
				| Terminal _ -> 1
				| Nonterminal _ -> 2
				| Dummy -> 3
				end
			) in
			let r = index x - index y in
			if r = 0 then (
				begin match x with
				| Epsilon | Dummy -> 0
				| Terminal xt ->
					begin match y with
					| Terminal yt -> Token.compare xt yt
					| _ -> assert false
					end
				| Nonterminal xn ->
					begin match y with
					| Nonterminal yn -> xn - yn
					| _ -> assert false
					end
				end
			) else (
				r
			)
		);;
	end;;
	
	let pp_symbol ~(pp_nonterminal: Format.formatter -> int -> unit)
		(f: Format.formatter) (s: symbol): unit =
	(
		begin match s with
		| Epsilon -> Format.pp_print_string f "(epsilon)"
		| Terminal t -> Token.pp_pattern ~quali:false ~paren:false f t
		| Nonterminal n -> pp_nonterminal f n
		| Dummy -> Format.pp_print_string f "(dummy)"
		end
	);;
	
	module SymbolSet = Set.Make (Symbol);;
	
	let pp_symbol_set ~(pp_nonterminal: Format.formatter -> int -> unit)
		(f: Format.formatter) (ss: SymbolSet.t): unit =
	(
		Format.fprintf f "{@[<hov>";
		let (_: bool) = SymbolSet.fold (fun i first ->
			if not first then (
				Format.fprintf f ",@ "
			);
			pp_symbol ~pp_nonterminal f i;
			false
		) ss true in
		Format.fprintf f "@]}"
	);;
	
	module SymbolMap = struct
		include Map.Make (Symbol);;
		let find_or ~not_found k m = (
			try find k m with Not_found -> not_found
		);;
	end;;
	
	let pp_symbol_map ~(pp_nonterminal: Format.formatter -> int -> unit)
		~(pp_elt: Format.formatter -> 'a -> unit)
		(f: Format.formatter) (sm: 'a SymbolMap.t): unit =
	(
		Format.fprintf f "{@,@[<hv>";
		let (_: bool) = SymbolMap.fold (fun k v first ->
			if not first then (
				Format.fprintf f ",@ "
			);
			Format.fprintf f "@[%a@] -> @[%a@]" (pp_symbol ~pp_nonterminal) k pp_elt v;
			false
		) sm true in
		Format.fprintf f "@]}"
	);;
	
	(* rule *)
	
	type rule = {
		left: int;
		elements: symbol array;
		semantic_action: SemanticAction.t};;
	
	let rule_left (r: rule): symbol = (
		Nonterminal r.left
	);;
	
	let rule_right (r: rule): symbol array = (
		r.elements
	);;
	
	let rule_semantic_action (r: rule): SemanticAction.t = (
		r.semantic_action
	);;
	
	let pp_rule ~(pp_nonterminal: Format.formatter -> int -> unit)
		(f: Format.formatter) ?(star: int = -1) ?(typed: bool = true) (r: rule): unit =
	(
		Format.fprintf f "@[<hov2>%a ::=" pp_nonterminal r.left;
		let (_: int) = Array.fold_left (fun i e ->
			if i = star then (
				Format.fprintf f "@ * "
			) else if i > 0 then (
				Format.fprintf f " >@ "
			) else (
				Format.fprintf f "@ "
			);
			Format.fprintf f "%a" (pp_symbol ~pp_nonterminal) e;
			succ i
		) 0 r.elements in
		if star >= Array.length r.elements then (
			Format.fprintf f "@ *"
		);
		if typed then (
			Format.fprintf f "@ -- %a" SemanticAction.pp r.semantic_action
		);
		Format.fprintf f "@]"
	);;
	
	(* core *)
	
	type core = {
		rule_index: int;
		cursor: int};;
	
	module Core = struct (* LR(0) term *)
		
		type t = core;;
		
		(* This is faster than using Pervasives.compare directly. *)
		let compare (x: t) (y: t): int = (
			let r_rule = Pervasives.compare x.rule_index y.rule_index in
			if r_rule <> 0 then r_rule else
			let r_cursor = Pervasives.compare x.cursor y.cursor in
			r_cursor
		);;
		
	end;;
	
	let pp_core ~(pp_nonterminal: Format.formatter -> int -> unit)
		(rules: rule array)
		(f: Format.formatter) (c: Core.t): unit =
	(
		Format.fprintf f "(%s)" (if c.rule_index = 0 then "-" else string_of_int c.rule_index);
		pp_rule ~star:c.cursor ~typed:false ~pp_nonterminal f rules.(c.rule_index)
	);;
	
	module CoreSet = Set.Make (Core);;
	
	let pp_core_set ~(pp_nonterminal: Format.formatter -> int -> unit)
		(rules: rule array)
		(f: Format.formatter) (cs: CoreSet.t): unit =
	(
		Format.fprintf f "{@[<hv>";
		let (_: bool) = CoreSet.fold (fun c first ->
			if not first then (
				Format.fprintf f ",@ "
			);
			pp_core ~pp_nonterminal rules f c;
			false
		) cs true in
		Format.fprintf f "@]}"
	);;
	
	module CoreSetSet = Set.Make (CoreSet);;
	
	module CoreSetMap = Map.Make (CoreSet);;
	
	module CoreMap = struct
		include Map.Make (Core);;
		let find_or ~not_found k m = (
			try find k m with Not_found -> not_found
		);;
	end;;
	
	let pp_core_map ~(pp_elt: Format.formatter -> 'a -> unit)
		(f: Format.formatter) (sm: 'a CoreMap.t): unit =
	(
		Format.fprintf f "{@,@[<hv>";
		let (_: bool) = CoreMap.fold (fun {rule_index = rule_index; cursor = cursor} v first ->
			if not first then (
				Format.fprintf f ",@ "
			);
			Format.fprintf f "@[(%d, %d)@] -> @[%a@]" rule_index cursor pp_elt v;
			false
		) sm true in
		Format.fprintf f "@]}"
	);;
	
	(* item *)
	
	type item = {
		core: Core.t;
		lookahead: symbol};;
	
	module Item = struct (* LR(1) term *)
		
		type t = item;;
		
		let compare (x: t) (y: t): int = (
			let r_core = Core.compare x.core y.core in
			if r_core <> 0 then r_core else
			let r_lookahead = Symbol.compare x.lookahead y.lookahead in
			r_lookahead
		);;
		
	end;;
	
	module ItemSet = Set.Make (Item);;
	
	(* propagate *)
	
	module Propagate = Set.Make (struct
		
		type t = (int * Core.t);; (* state index, LR(0) term *)
		
		let compare ((xf, xs): t) ((yf, ys): t) = (
			let r_f = Pervasives.compare xf yf in
			if r_f <> 0 then r_f else
			let r_s = Core.compare xs ys in
			r_s
		);;
	
	end);;
	
	(* state *)
	
	type state = {
		no: int;
		cores: CoreSet.t;
		kernel: CoreSet.t; (* excluded not root and cursor = 0 from cores *)
		mutable items: ItemSet.t; (* pairs of kernel with look-ahead symbol *)
		mutable generate_map: SymbolSet.t CoreMap.t;
		mutable propagate_map: Propagate.t CoreMap.t;
		mutable goto_table: int SymbolMap.t; (* nonterminal index -> next state *)
		mutable action_table: (int * action) TokenMap.t; (* token -> rule index, action *)
		mutable otherwise_action: (int * action) option};;
	
	let no (s: state): int = (
		s.no
	);;
	
	let core_set (s: state): CoreSet.t = (
		s.cores
	);;
	
	let goto_table (s: state): int SymbolMap.t = (
		s.goto_table
	);;
	
	let action_table (s: state): (int * action) TokenMap.t = (
		s.action_table
	);;
	
	let otherwise_action (s: state): (int * action) option = (
		s.otherwise_action
	);;
	
	(* generated parsing table *)
	
	type table = {
		rules: rule array;
		states: state array;
		first: int;
		nonterminals: symbol array};;
	
	module Private = struct
		
		let collect_symbols (rules: rule array): SymbolSet.t * SymbolSet.t * SymbolSet.t = (
			let terminals = ref SymbolSet.empty in
			let nonterminals = ref SymbolSet.empty in
			let all_symbols = ref SymbolSet.empty in
			for i = 1 to Array.length rules - 1 do
				let r = rules.(i) in
				let left = Nonterminal r.left in
				nonterminals := SymbolSet.add left !nonterminals;
				all_symbols := SymbolSet.add left !all_symbols;
				for j = 0 to Array.length r.elements - 1 do
					let s = r.elements.(j) in
					all_symbols := SymbolSet.add s !all_symbols;
					begin match s with
					| Epsilon -> ()
					| Terminal _ -> terminals := SymbolSet.add s !terminals
					| Nonterminal _ -> nonterminals := SymbolSet.add s !nonterminals
					| Dummy -> assert false
					end
				done
			done;
			(!terminals, !nonterminals, !all_symbols)
		);;
		
		let make_first_and_follow
			~(terminals: SymbolSet.t) ~(nonterminals: SymbolSet.t)
			(rules: rule array): SymbolSet.t SymbolMap.t * SymbolSet.t SymbolMap.t =
		(
			let rec all_nullable (nullable: SymbolSet.t) (rule_right: symbol array) (b: int) (e: int): bool = (
				if b < e then (
					let r = rule_right.(b) in
					if r <> Epsilon && not (SymbolSet.mem r nullable) then (
						false
					) else (
						all_nullable nullable rule_right (b + 1) e
					)
				) else (
					true
				)
			) in
			let first = ref SymbolMap.empty in
			let follow = ref SymbolMap.empty in
			let nullable = ref SymbolSet.empty in
			SymbolSet.iter (fun s ->
				first := SymbolMap.add s (SymbolSet.add s SymbolSet.empty) !first
			) terminals;
			(* repeat until FIRST, FOLLOW, and nullable did not change in this iteration. *)
			let repeat = ref true in
			while !repeat do
				repeat := false;
				(* for each production X -> Y1Y2...Yk *)
				for i = 1 to Array.length rules - 1 do
					let rule = rules.(i) in
					let k = Array.length rule.elements in
					(* if Y1...Yk are all nullable ( or if k = 0 ) *)
					if all_nullable !nullable rule.elements 0 k then (
						let left = Nonterminal rule.left in
						if not (SymbolSet.mem left !nullable) then (
							repeat := true;
							nullable := SymbolSet.add left !nullable
						)
					);
					(* for each i from 1 to k, each j from i + 1 to k *)
					for i = 0 to k - 1 do
						(* if Y1...Yi-1 are all nullable ( or if i = 1) then FIRST[X] = FIRST[X] unify FIRST[Yi] *)
						if all_nullable !nullable rule.elements 0 i then (
							let left = Nonterminal rule.left in
							let s1 = SymbolMap.find_or ~not_found:SymbolSet.empty left !first in
							let s2 = SymbolMap.find_or ~not_found:SymbolSet.empty rule.elements.(i) !first in
							let s3 = SymbolSet.union s1 s2 in
							if SymbolSet.compare s1 s3 <> 0 then (
								repeat := true;
								first := SymbolMap.add left s3 !first
							)
						);
						(* if Yi+1...Yk are all nullable ( or if i = k ) then FOLLOW[Yi] = FOLLOW[Yi] unify FOLLOW[X] *)
						if all_nullable !nullable rule.elements (i + 1) k then (
							let right_i = rule.elements.(i) in
							let s1 = SymbolMap.find_or ~not_found:SymbolSet.empty right_i !follow in
							let s2 = SymbolMap.find_or ~not_found:SymbolSet.empty (Nonterminal rule.left) !follow in
							let s3 = SymbolSet.union s1 s2 in
							if SymbolSet.compare s1 s3 <> 0 then (
								repeat := true;
								follow := SymbolMap.add right_i s3 !follow
							)
						);
						(* if Yi+1...Yj-1 are all nullable ( or if i+1 = j ) then FOLLOW[Yi] = FOLLOW[Yi] unify FIRST[Yj] *)
						for j = i + 1 to k - 1 do
							if all_nullable !nullable rule.elements (i + 1) j then (
								let right_i = rule.elements.(i) in
								let s1 = SymbolMap.find_or ~not_found:SymbolSet.empty right_i !follow in
								let s2 = SymbolMap.find_or ~not_found:SymbolSet.empty rule.elements.(j) !first in
								let s3 = SymbolSet.union s1 s2 in
								if SymbolSet.compare s1 s3 <> 0 then (
									repeat := true;
									follow := SymbolMap.add right_i s3 !follow
								)
							)
						done
					done
				done
			done;
			SymbolSet.iter (fun i ->
				let s1 = SymbolMap.find_or ~not_found:SymbolSet.empty i !first in
				first := SymbolMap.add i (SymbolSet.add Epsilon s1) !first
			) !nullable;
			(!first, !follow)
		);;
		
		let make_vector_first (first: SymbolSet.t SymbolMap.t) (vs: symbol array): SymbolSet.t = (
			let rec loop (s: SymbolSet.t) i next = (
				if i >= Array.length vs then (
					if next then (
						assert (SymbolSet.is_empty s);
						SymbolSet.add Epsilon s
					) else (
						s
					)
				) else (
					let v = vs.(i) in
					begin match v with
					| Terminal _ | Dummy ->
						SymbolSet.add v s
					| Nonterminal _ | Epsilon ->
						let f = SymbolMap.find v first in
						let next = ref false in
						let s2 = SymbolSet.fold (fun k s ->
							begin match k with
							| Epsilon ->
								next := true;
								s
							| Terminal _ | Nonterminal _ | Dummy ->
								SymbolSet.add k s
							end
						) f s in
						if !next then (
							loop s2 (i + 1) true
						) else (
							s2
						)
					end
				)
			) in
			loop SymbolSet.empty 0 false
		);;
		
		let make_lr0_closure (j: CoreSet.t) (rules: rule array): CoreSet.t = (
			let j = ref j in
			let added = ref SymbolSet.empty in
			let repeat = ref true in
			let new_cores = ref CoreSet.empty in
			while !repeat do
				repeat := false;
				new_cores := CoreSet.empty;
				CoreSet.iter (fun x ->
					let rule = rules.(x.rule_index) in
					if x.cursor < Array.length rule.elements then (
						let y = rule.elements.(x.cursor) in
						begin match y with
						| Terminal _ | Epsilon | Dummy -> ()
						| Nonterminal yn ->
							for n = 1 to Array.length rules - 1 do
								let z = rules.(n) in
								if yn = z.left then (
									let z_left = Nonterminal z.left in
									if not (SymbolSet.mem z_left !added) then (
										let new_core = {rule_index = n; cursor = 0} in
										new_cores := CoreSet.add new_core !new_cores;
										repeat := true
									)
								)
							done;
							added := SymbolSet.add y !added
						end
					)
				) !j;
				j := CoreSet.union !new_cores !j
			done;
			!j
		);;
		
		let make_lr0_goto (i: CoreSet.t) (sx: symbol) (rules: rule array): CoreSet.t = (
			let j = ref CoreSet.empty in
			CoreSet.iter (fun x ->
				let rule = rules.(x.rule_index) in
				if x.cursor < Array.length rule.elements then (
					let y = rule.elements.(x.cursor) in
					if y = sx then (
						let new_core = {rule_index = x.rule_index; cursor = x.cursor + 1} in
						j := CoreSet.add new_core !j
					)
				)
			) i;
			make_lr0_closure !j rules
		);;
		
		let make_lr0_collection (root: core) (rules: rule array) (syms: SymbolSet.t): CoreSetSet.t = (
			let s = CoreSet.add root CoreSet.empty in
			let s = make_lr0_closure s rules in
			let result = ref (CoreSetSet.add s CoreSetSet.empty) in
			let repeat = ref true in
			let new_collection = ref CoreSetSet.empty in
			while !repeat do
				repeat := false;
				new_collection := CoreSetSet.empty;
				CoreSetSet.iter (fun i ->
					SymbolSet.iter (fun x ->
						let i_dash = make_lr0_goto i x rules in
						if not (CoreSet.is_empty i_dash) && not (CoreSetSet.mem i_dash !result) then (
							new_collection := CoreSetSet.add i_dash !new_collection;
							repeat := true
						)
					) syms
				) !result;
				result := CoreSetSet.union !new_collection !result
			done;
			!result
		);;
		
		let rec make_lr1_closure (j: ItemSet.t) (first: SymbolSet.t SymbolMap.t) (rules: rule array): ItemSet.t = (
			let new_items = ref ItemSet.empty in
			ItemSet.iter (fun x -> (* x is [item(A -> alpha . B beta, a)] *)
				let x_rule = rules.(x.core.rule_index) in
				if x.core.cursor < Array.length x_rule.elements then (
					(* y is [symbol(B)] *)
					let y = x_rule.elements.(x.core.cursor) in
					begin match y with
					| Epsilon | Terminal _ | Dummy -> ()
					| Nonterminal yn ->
						(* v is [symbol_vector_type(beta a)] *)
						let x_r_len = Array.length x_rule.elements in
						let v = Array.make (x_r_len - x.core.cursor) x.lookahead in
						let s = x.core.cursor + 1 in
						for j = s to x_r_len - 1 do
							v.(j - s) <- x_rule.elements.(j)
						done;
						(* f is FIRST(beta a) *)
						let f = make_vector_first first v in
						for i = 1 to Array.length rules - 1 do (* z is [rule(beta -> gamma)] *)
							let z = rules.(i) in
							if yn = z.left then (
								SymbolSet.iter (fun k ->
									new_items := ItemSet.add
										{core = {rule_index = i; cursor = 0}; lookahead = k}
										!new_items
								) f
							)
						done
					end
				)
			) j;
			let j_size = ItemSet.cardinal j in
			let result = ItemSet.union !new_items j in
			if ItemSet.cardinal result <> j_size then (
				make_lr1_closure result first rules
			) else (
				result
			)
		);;
		
		let make_lr1_goto (i_set: ItemSet.t) (sx: symbol) (first: SymbolSet.t SymbolMap.t) (rules: rule array): ItemSet.t = (
			let j = ref ItemSet.empty in
			ItemSet.iter (fun x ->
				let x_rule = rules.(x.core.rule_index) in
				if x.core.cursor < Array.length x_rule.elements then (
					let y = x_rule.elements.(x.core.cursor) in
					if y = sx then (
						j := ItemSet.add {core = {rule_index = x.core.rule_index; cursor = x.core.cursor + 1};
							lookahead = x.lookahead} !j
					)
				)
			) i_set;
			make_lr1_closure !j first rules
		);;
		
		let choose_kernel (i: CoreSet.t): CoreSet.t = (
			CoreSet.fold (fun x result ->
				if x.rule_index = 0 || x.cursor > 0 then (
					CoreSet.add x result
				) else (
					result
				)
			) i CoreSet.empty
		);;
		
		let select_first_state (states: state array): int = (
			let rec loop states i length result = (
				if i >= length then (
					!result
				) else (
					let state = states.(i) in
					if ItemSet.exists
						(
							fun j ->
							if j.core.cursor = 0 && j.core.rule_index = 0 then (
								result := state.no;
								true
							) else (
								false
							)
						) state.items
					then (
						!result
					) else (
						loop states (i + 1) length result
					)
				)
			) in
			loop states 0 (Array.length states) (ref (-1))
		);;
		
		let pp_begin_section (f: Format.formatter) (title: string): unit = (
			Format.fprintf f "### %s ### (user-time:%f)@." title (Sys.time ())
		);;
		
		let pp_end_section (f: Format.formatter) (): unit = (
			Format.fprintf f "# (user-time:%f)@." (Sys.time ())
		);;
		
		module ErrorHandling = struct
			
			let min_length_of_symbol (rules: rule array) ~(terminals: SymbolSet.t): int SymbolMap.t = (
				let rules_length = Array.length rules in
				let length_of_rule = Array.make rules_length max_int in
				let length_of_symbol = ref (SymbolSet.fold (fun s -> SymbolMap.add s 1) terminals SymbolMap.empty) in
				let repeat = ref true in
				while !repeat do
					repeat := false;
					for i = rules_length - 1 downto 1 do
						let rec loop j length = (
							if j >= Array.length rules.(i).elements then (
								length_of_rule.(i) <- length;
								let left = Nonterminal rules.(i).left in
								if length < SymbolMap.find_or ~not_found:max_int left !length_of_symbol then (
									length_of_symbol := SymbolMap.add left length !length_of_symbol;
									repeat := true
								)
							) else (
								let e = rules.(i).elements.(j) in
								let el = SymbolMap.find_or ~not_found:max_int e !length_of_symbol in
								if el < max_int then loop (succ j) (length + el)
							)
						) in
						loop 0 0
					done
				done;
				!length_of_symbol
			);;
			
			let map_of_set (value: int) (s: SymbolSet.t): int SymbolMap.t = (
				SymbolSet.fold (fun e r -> SymbolMap.add e value r) s SymbolMap.empty
			);;
			
			let set_of_map (s: int SymbolMap.t): SymbolSet.t = (
				SymbolMap.fold (fun k _ r -> SymbolSet.add k r) s SymbolSet.empty
			);;
			
			(* super first set : symbol -> (symbol * distance) set *)
			(* super follow set :  symbol -> core -> symbol set *)
			let make_super_first_and_follow ~(nonterminals: SymbolSet.t) (rules: rule array)
				~(first: SymbolSet.t SymbolMap.t) ~(follow: SymbolSet.t SymbolMap.t)
				: (int SymbolMap.t) SymbolMap.t * SymbolSet.t CoreMap.t SymbolMap.t =
			(
				let merge (m1: int SymbolMap.t) (m2: int SymbolMap.t): int SymbolMap.t = (
					SymbolMap.fold (fun k v r ->
						if v < SymbolMap.find_or ~not_found:max_int k r then (
							SymbolMap.add k v r
						) else (
							r
						)
					) m1 m2
				) in
				let look_right_index_of_symbol = (
					Array.fold_left (fun result rule ->
						let left = Nonterminal rule.left in
						let last_of_elements = max 0 (Array.length rule.elements - 1) in
						try
							let (right_index, rule2) = SymbolMap.find left result in
							let rec loop i = (
								if i = right_index || i = last_of_elements then i else
								if Symbol.compare rule.elements.(i) rule2.elements.(i) <> 0 then i else
								loop (i + 1)
							) in
							let new_right_index = loop 0 in
							if new_right_index < right_index then (
								SymbolMap.add left (new_right_index, rule2) result
							) else (
								result
							)
						with Not_found -> SymbolMap.add left (last_of_elements, rule) result
					) SymbolMap.empty rules
				) in
				let super_first = ref (SymbolMap.map (map_of_set 0) first) in
				let repeat = ref true in
				while !repeat do
					repeat := false;
					for i = 1 to Array.length rules - 1 do
						let rule = rules.(i) in
						let left = Nonterminal rule.left in
						let (right_index, _) = SymbolMap.find left look_right_index_of_symbol in
						for j = 1 to right_index do
							let f1 = SymbolMap.find_or ~not_found:SymbolMap.empty left !super_first in
							let f2 = SymbolMap.map (( + ) j) (SymbolMap.find rule.elements.(j) !super_first) in
							let new_super_first = SymbolMap.add left (merge f1 f2) !super_first in
							if SymbolMap.compare (SymbolMap.compare Pervasives.compare) new_super_first !super_first <> 0 then (
								super_first := new_super_first;
								repeat := true
							)
						done
					done
				done;
				let super_follow: SymbolSet.t CoreMap.t SymbolMap.t ref = ref SymbolMap.empty in
				let add (left: symbol) (pos: core) (s: SymbolSet.t): unit = (
					let x1 = SymbolMap.find_or ~not_found:CoreMap.empty left !super_follow in
					if CoreMap.mem pos x1 then (
						let s1 = CoreMap.find pos x1 in
						if not (SymbolSet.subset s s1) then (
							let s2 = SymbolSet.union s s1 in
							let x2 = CoreMap.add pos s2 x1 in
							super_follow := SymbolMap.add left x2 !super_follow;
							repeat := true
						)
					) else (
						let x2 = CoreMap.add pos s x1 in
						super_follow := SymbolMap.add left x2 !super_follow;
						repeat := true
					)
				) in
				let overwrite (left: symbol) (pos: core) (s: SymbolSet.t): unit = (
					let x1 = SymbolMap.find_or ~not_found:CoreMap.empty left !super_follow in
					if CoreMap.mem pos x1 then (
						let s1 = CoreMap.find pos x1 in
						if SymbolSet.compare s s1 <> 0 then (
							let x2 = CoreMap.add pos s x1 in
							super_follow := SymbolMap.add left x2 !super_follow;
							repeat := true
						)
					) else (
						let x2 = CoreMap.add pos s x1 in
						super_follow := SymbolMap.add left x2 !super_follow;
						repeat := true
					)
				) in
				let all_nullable = ref true in
				repeat := true;
				while !repeat do
					repeat := false;
					for i = 1 to Array.length rules - 1 do
						let rule = rules.(i) in
						for j = 0 to Array.length rule.elements - 1 do
							let left = rule.elements.(j) in
							all_nullable := true;
							for k = succ j to Array.length rule.elements - 1 do
								if not (SymbolSet.mem Epsilon (SymbolMap.find rule.elements.(k) first)) then (
									all_nullable := false;
									let s = set_of_map (SymbolMap.find rule.elements.(k) !super_first) in
									add left {rule_index = i; cursor = j} s
								)
							done;
							if !all_nullable then (
								let ss = SymbolMap.find_or ~not_found:CoreMap.empty (Nonterminal rule.left) !super_follow in
								CoreMap.iter (fun pos s -> overwrite left pos s) ss
							)
						done
					done
				done;
				(!super_first, !super_follow)
			);;
			
			let make_same_symbols (rules: rule array): SymbolSet.t SymbolMap.t = (
				let result = ref (Array.fold_left (fun result rule ->
					let left = Nonterminal rule.left in
					let m = SymbolMap.find_or ~not_found:SymbolSet.empty left result in
					let m = SymbolSet.add left m in
					let m = (
						if Array.length rule.elements = 1 then (
							match rule.elements.(0) with
							| Nonterminal _ as right -> SymbolSet.add right m
							| Terminal _ | Epsilon | Dummy -> m
						) else (
							m
						)
					) in
					SymbolMap.add left m result
				) SymbolMap.empty rules) in
				while
					let old = !result in
					result := SymbolMap.fold (fun key value result ->
						SymbolSet.fold (fun i result ->
							let m = SymbolSet.union value (SymbolMap.find i old) in
							SymbolMap.add key m result
						) value result
					) old old;
					SymbolMap.compare (SymbolSet.compare) old !result <> 0
				do () done;
				!result
			);;
			
			let at_last (rules: rule array) (state: state): bool = (
				CoreSet.for_all (fun i ->
					i.cursor >= Array.length rules.(i.rule_index).elements
				) state.kernel
			);;
			
			let error_shift_action ~(first: SymbolSet.t SymbolMap.t)
				(expected: symbol) (rules: rule array) (state: state): (int * action) option =
			(
				begin match expected with
				| Epsilon | Dummy -> assert false
				| Terminal et ->
					let (ri, a) = TokenMap.find et state.action_table in
					begin match a with
					| Reduce _ ->
						None
					| Shift dest | ErrorShiftTerminal (_, dest) ->
						let new_action = ErrorShiftTerminal (TokenSet.add et TokenSet.empty, dest) in
						Some (ri, new_action)
					| ErrorReduce _ | ErrorShiftNonterminal _ | Accept -> assert false
					end
				| Nonterminal rn ->
					let ri = (
						let rec loop i = (
							if i >= Array.length rules then (
								assert false
							) else if rules.(i).left = rn then (
								i
							) else (
								loop (i + 1)
							)
						) in
						loop 0
					) in
					let first_set = SymbolMap.find expected first in
					let sa = rules.(ri).semantic_action in
					let goto = SymbolMap.find expected state.goto_table in
					let optional = SymbolSet.mem Epsilon first_set in
					let f = SymbolSet.fold (fun s r ->
						begin match s with
						| Nonterminal _ -> assert false
						| Terminal t -> TokenSet.add t r
						| Dummy | Epsilon -> r
						end
					) first_set TokenSet.empty in
					let new_action = ErrorShiftNonterminal (f, sa, optional, goto) in
					Some (ri, new_action)
				end
			);;
			
			type shift_recovering_state =
				| NoRecovery
				| Recovery of int * int * (int * action) (* rule, cursor, (rule index, action) *)
				| ConflictTerminal
				| ConflictNonterminal;;
			
			let select (r1: shift_recovering_state) (r2: shift_recovering_state): shift_recovering_state = (
				begin match r1, r2 with
				| Recovery (ri1, cu1, _), Recovery (ri2, cu2, _) ->
					if cu1 < cu2 then r2 else
					if ri1 < ri2 then r1 else r2
				| _ -> assert false
				end
			);;
			
			let error_shift_merge (rules: rule array) (t: Token.t)
				(r1: shift_recovering_state) (r2: shift_recovering_state): shift_recovering_state =
			(
				begin match r1 with
				| Recovery (ri1, cu1, (ni1, ErrorShiftTerminal (t1, st1))) ->
					begin match r2 with
					| Recovery (ri2, _, (_, ErrorShiftTerminal (t2, st2))) ->
						if st1 = st2 then (
							Recovery (ri1, cu1, (ni1, ErrorShiftTerminal ((TokenSet.union t1 t2), st1)))
						) else if rules.(ri1).left = rules.(ri2).left && Token.compare t Token.eof <> 0 then (
							ConflictTerminal
						) else (
							select r1 r2
						)
					| Recovery (_, _, (_, ErrorShiftNonterminal _)) -> r2
					| Recovery _ | NoRecovery | ConflictTerminal | ConflictNonterminal -> assert false
					end
				| ConflictTerminal ->
					begin match r2 with
					| Recovery (_, _, (_, ErrorShiftTerminal _)) -> ConflictTerminal
					| Recovery (_, _, (_, ErrorShiftNonterminal _)) -> r2
					| Recovery _ | NoRecovery | ConflictTerminal | ConflictNonterminal -> assert false
					end
				| Recovery (ri1, cu1, (ni1, ErrorShiftNonterminal (t1, sa1, o1, st1))) ->
					begin match r2 with
					| Recovery (_, _, (_, ErrorShiftTerminal _)) -> r1
					| Recovery (ri2, _, (_, ErrorShiftNonterminal (t2, sa2, o2, st2))) ->
						if SemanticAction.compare sa1 sa2 = 0 && st1 = st2 then (
							Recovery (ri1, cu1, (ni1, ErrorShiftNonterminal ((TokenSet.union t1 t2), sa1, o1 || o2, st1)))
						) else if rules.(ri1).left = rules.(ri2).left && Token.compare t Token.eof <> 0 then (
							ConflictNonterminal
						) else (
							select r1 r2
						)
					| Recovery _ | NoRecovery | ConflictTerminal | ConflictNonterminal -> assert false
					end
				| ConflictNonterminal -> ConflictNonterminal
				| Recovery _ | NoRecovery -> assert false
				end
			);;
			
			let be_recursive ~(same_symbols: SymbolSet.t SymbolMap.t) (rule: rule) (cursor: int): bool = (
				let es = rule.elements in
				if cursor >= Array.length es then (
					false
				) else (
					begin match es.(cursor) with
					| Nonterminal _ as e ->
						let sames = SymbolMap.find_or ~not_found:SymbolSet.empty e same_symbols in
						let reduced = Nonterminal rule.left in
						SymbolSet.mem reduced sames
					| Terminal _ | Epsilon -> false
					| Dummy -> assert false
					end
				)
			);;
			
			let union_sfs (sfs: SymbolSet.t CoreMap.t): SymbolSet.t = (
				CoreMap.fold (fun _ x r -> SymbolSet.union x r) sfs SymbolSet.empty
			);;
			
			let follow_of_left_recursive
				~(super_first: (int SymbolMap.t) SymbolMap.t) ~(super_follow: SymbolSet.t CoreMap.t SymbolMap.t)
				~(not_left_recursives: CoreSet.t)
				(rules: rule array) (left: symbol): SymbolSet.t =
			(
				CoreSet.fold (fun i result ->
					let rule = rules.(i.rule_index) in
					let rec loop index result = (
						if index >= Array.length rule.elements then (
							result
						) else (
							let result = (
								if Symbol.compare rule.elements.(index) left = 0 then (
									if index + 1 >= Array.length rule.elements then (
										SymbolSet.union (union_sfs (SymbolMap.find_or ~not_found:CoreMap.empty (Nonterminal rule.left) super_follow)) result
									) else (
										SymbolSet.union (set_of_map (SymbolMap.find rule.elements.(index + 1) super_first)) result
									)
								) else (
									result
								)
							) in
							loop (index + 1) result
						)
					) in
					loop 0 result
				) not_left_recursives SymbolSet.empty
			);;
			
			let rec is_error (rules: rule array) (state: state) (i: core) (f: CoreSet.t ref): bool = (
				not (CoreSet.mem i !f) && (
					f := CoreSet.add i !f;
					i.cursor = 0 &&
					let i_rule = rules.(i.rule_index) in
					SemanticAction.is_error i_rule.semantic_action || (
						let self_symbol = Nonterminal i_rule.left in
						CoreSet.exists (fun j ->
							let j_rule = rules.(j.rule_index) in
							Array.length j_rule.elements > 0
							&& Symbol.compare j_rule.elements.(0) self_symbol = 0
							&& is_error rules state j f
						) state.cores
					)
				)
			);;
			
			let generate_error_recovery (f: Format.formatter)
				~(debug: bool)
				~(min_length_of_symbol: int SymbolMap.t)
				~(first: SymbolSet.t SymbolMap.t) ~(follow: SymbolSet.t SymbolMap.t)
				~(super_first: (int SymbolMap.t) SymbolMap.t) ~(super_follow: SymbolSet.t CoreMap.t SymbolMap.t)
				~(same_symbols: SymbolSet.t SymbolMap.t)
				(rules: rule array) (states: state array): unit =
			(
				for i_st = 0 to Array.length states - 1 do
					let st = states.(i_st) in
					if debug then Format.fprintf f "state %d: @[<hov1>" st.no;
					(* error shift *)
					let shifts: (int * shift_recovering_state) TokenMap.t ref = ref TokenMap.empty in
					let (left_recursives, not_left_recursives) = (
						CoreSet.fold (fun i (left_recursives, not_left_recursives) ->
							if be_recursive ~same_symbols rules.(i.rule_index) 0 then (
								(CoreSet.add i left_recursives, not_left_recursives)
							) else (
								(left_recursives, CoreSet.add i not_left_recursives)
							)
						) st.cores (CoreSet.empty, CoreSet.empty)
					) in
					CoreSet.iter (fun i ->
						let no_kernel_weight = 0x40000 in
						let between_weight = 4 in (* 0x00004..0x3fffc *)
						let left_recursive_weight = 2 in
						let going_recursive_weight = 1 in
						let i_rule = rules.(i.rule_index) in
						let i_length = Array.length i_rule.elements in
						if i.cursor < i_length then (
							let expected = i_rule.elements.(i.cursor) in
							if i.rule_index = 0 || i.cursor > 0
								|| not (SymbolSet.mem Epsilon (SymbolMap.find expected first)) then
							(
								let between = ref 0 in (* no counting the expected symbol *)
								let left_recursive = CoreSet.mem i left_recursives in
								let going_recursive = be_recursive ~same_symbols i_rule (i.cursor + 1) in
								let is_error = is_error rules st i (ref CoreSet.empty) in
								for j = i.cursor + 1 to i_length do
									let next_expected_symbols = (
										if j < i_length then (
											if is_error then (
												SymbolMap.empty
											) else (
												SymbolMap.find i_rule.elements.(j) super_first
											)
										) else (
											let self_symbol = Nonterminal i_rule.left in
											let self_follow = (
												if left_recursive then (
													follow_of_left_recursive ~super_first ~super_follow
														~not_left_recursives rules self_symbol
												) else if i.cursor = 0 then (
													SymbolSet.empty
												) else (
													union_sfs (SymbolMap.find_or ~not_found:CoreMap.empty self_symbol super_follow)
												)
											) in
											let self_follow = SymbolSet.add (Terminal Token.eof) self_follow in
											map_of_set 0xffff self_follow
										)
									) in
									let weight = (
										(if i.rule_index = 0 || i.cursor > 0 then 0 else no_kernel_weight) +
										(if not left_recursive then 0 else left_recursive_weight) +
										(if not going_recursive then 0 else going_recursive_weight)
									) in
									SymbolMap.iter (fun s between_of_s ->
										let weight = weight + between_weight * min 0xffff (!between + between_of_s) in
										begin match s with
										| Nonterminal _ -> assert false
										| Dummy | Epsilon -> ()
										| Terminal t ->
											begin match error_shift_action ~first expected rules st with
											| None -> ()
											| Some rsa ->
												let (b2, a2) = TokenMap.find_or ~not_found:(max_int, NoRecovery) t !shifts in
												if weight < b2 then (
													if debug then Format.fprintf f "@ @[(%d), %a, %d;@]" i.rule_index (Token.pp_pattern ~paren:false ~quali:false) t weight;
													let rss = Recovery (i.rule_index, i.cursor, rsa) in
													shifts := TokenMap.add t (weight, rss) !shifts
												) else if weight = b2 then (
													let rss1 = Recovery (i.rule_index, i.cursor, rsa) in
													let ma = error_shift_merge rules t a2 rss1 in
													if ma != a2 then (
														if debug then Format.fprintf f "@ @[(%d), %a, %d;@]" i.rule_index (Token.pp_pattern ~paren:false ~quali:false) t weight;
														shifts := TokenMap.add t (b2, ma) !shifts
													)
												)
											end
										end
									) next_expected_symbols;
									if j < i_length then (
										between := !between + SymbolMap.find i_rule.elements.(j) min_length_of_symbol
									)
								done
							)
						) else if i.cursor > 0 then (
							let left_recursive = CoreSet.mem i left_recursives in
							let next_expected_symbols = (
								let self_follow = (
									let self_symbol = Nonterminal i_rule.left in
									if not left_recursive then (
										union_sfs (SymbolMap.find_or ~not_found:CoreMap.empty self_symbol super_follow)
									) else (
										follow_of_left_recursive ~super_first ~super_follow
											~not_left_recursives rules self_symbol
									)
								) in
								SymbolSet.add (Terminal Token.eof) self_follow
							) in
							SymbolSet.iter (fun s ->
								begin match s with
								| Nonterminal _ -> assert false
								| Dummy | Epsilon -> ()
								| Terminal t ->
									let weight = between_weight in (* shift 1 token for ex: X * ";" Xs *)
									let (b2, _) = TokenMap.find_or ~not_found:(max_int, NoRecovery) t !shifts in
									if weight <= b2 then (
										shifts := TokenMap.add t (0, ConflictNonterminal) !shifts
									)
								end
							) next_expected_symbols
						)
					) st.cores;
					TokenMap.iter (fun t (_, sas) ->
						if not (TokenMap.mem t st.action_table) then (
							begin match sas with
							| Recovery (_, _, sa) ->
								st.action_table <- TokenMap.add t sa st.action_table
							| NoRecovery | ConflictTerminal | ConflictNonterminal -> ()
							end
						)
					) !shifts;
					(* error reduce *)
					let reduce = TokenMap.fold (fun _ (r, action) result ->
						begin match action with
						| Reduce (p, s, n) ->
							begin match result with
							| Some (_, ErrorReduce (p2, _, _)) when p2 > p -> (* reduce/reduce conflicted? *)
								result
							| _ ->
								Some (r, ErrorReduce (p, s, n))
							end
						| _ -> result
						end
					) st.action_table None in
					begin match reduce with
					| Some (_, ErrorReduce (rp, _, nti) as ra) ->
						(* overwrite error shift nonterminal that's able to be epsilon *)
						TokenMap.iter (fun t (_, action) ->
							begin match action with
							| ErrorShiftNonterminal (_, _, true, _) ->
								st.action_table <- TokenMap.add t ra st.action_table
							| _ -> ()
							end
						) st.action_table;
						(* all rules have at last? *)
						if at_last rules st then (
							st.otherwise_action <- Some ra
						) else (
							(* follow set *)
							let all_follow = union_sfs (SymbolMap.find_or ~not_found:CoreMap.empty (Nonterminal nti) super_follow) in
							SymbolSet.iter (fun s ->
								begin match s with
								| Terminal t ->
									if not (TokenMap.mem t st.action_table) then (
										st.action_table <- TokenMap.add t ra st.action_table
									)
								| _ -> ()
								end
							) all_follow;
							(* force overwrite eof to reduce *)
							if not (TokenMap.mem Token.eof st.action_table) || (rp > 0 &&
								match TokenMap.find Token.eof st.action_table with
								| (_, ErrorShiftTerminal _) | (_, ErrorShiftNonterminal _) -> true
								| _ -> false)
							then (
								st.action_table <- TokenMap.add Token.eof ra st.action_table
							)
						)
					| _ -> ()
					end;
					assert (TokenMap.mem Token.eof st.action_table
						|| st.otherwise_action <> None);
					if debug then Format.fprintf f "@]@."
				done
			);;
			
		end;;
		
	end;;
	open Private;;
	
	let create ~(pp_nonterminal: Format.formatter -> int -> unit)
		(f: Format.formatter)
		~(debug: bool) ~(error_handling: bool)
		~(shift_reduce_conflict: rule -> rule -> unit)
		~(reduce_reduce_conflict: rule -> rule -> unit)
		(rules: rule array): table =
	(
		(* check rules *)
		if debug then pp_begin_section f "rules";
		let root_rule = rules.(0) in
		assert (Array.length root_rule.elements = 1);
		if debug then (
			pp_end_section f ();
			for i = 0 to Array.length rules - 1 do
				let r = rules.(i) in
				Format.fprintf f "(%d)%a@." i (pp_rule ~pp_nonterminal ?star:None ?typed:None) r
			done
		);
		(* symbols *)
		if debug then pp_begin_section f "symbols";
		let (terminals, nonterminals, all_symbols) = collect_symbols rules in
		if debug then (
			pp_end_section f ();
			Format.fprintf f "@[<hov2>terminals:@ %a@]@." (pp_symbol_set ~pp_nonterminal) terminals;
			Format.fprintf f "@[<hov2>non-terminals:@ %a@]@." (pp_symbol_set ~pp_nonterminal) nonterminals;
			Format.fprintf f "@[<hov2>all:@ %a@]@." (pp_symbol_set ~pp_nonterminal) all_symbols
		);
		(* first set, follow set *)
		if debug then pp_begin_section f "first and follow set";
		let (first, follow) = make_first_and_follow ~terminals ~nonterminals rules in
		if debug then (
			Format.fprintf f "@[<hov2>first-set:@ %a@]@."
				(pp_symbol_map ~pp_nonterminal ~pp_elt:(pp_symbol_set ~pp_nonterminal)) first;
			Format.fprintf f "@[<hov2>follow-set:@ %a@]@."
				(pp_symbol_map ~pp_nonterminal ~pp_elt:(pp_symbol_set ~pp_nonterminal)) follow
		);
		(* LR(0) collection *)
		if debug then pp_begin_section f "LR(0) collection";
		let root_core = {rule_index = 0; cursor = 0} in
		let i_set = make_lr0_collection root_core rules all_symbols in
		if debug then (
			pp_end_section f ();
			let (_: int) = CoreSetSet.fold (fun cs i ->
				Format.fprintf f "@[<hv2>%d: %a@]@." i (pp_core_set ~pp_nonterminal rules) cs;
				succ i
			) i_set 0 in ()
		);
		(* states *)
		if debug then pp_begin_section f "states";
		let dummy_state = {no = -1; cores = CoreSet.empty; kernel = CoreSet.empty;
			items = ItemSet.empty; generate_map = CoreMap.empty; propagate_map = CoreMap.empty;
			goto_table = SymbolMap.empty; action_table = TokenMap.empty; otherwise_action = None}
		in
		let states = Array.make (CoreSetSet.cardinal i_set) dummy_state in
		let kernels = ref CoreSetMap.empty in (* I(kernel) -> state *)
		let (_: int) = CoreSetSet.fold (fun i index ->
			let k = choose_kernel i in
			let g = (
				if CoreSet.mem root_core k then (
					CoreMap.add root_core (SymbolSet.add (Terminal Token.eof) SymbolSet.empty) CoreMap.empty
				) else (
					CoreMap.empty
				)
			) in
			let s = {
				no = index;
				cores = i;
				kernel = k;
				items = ItemSet.empty;
				generate_map = g;
				propagate_map = CoreMap.empty;
				goto_table = SymbolMap.empty;
				action_table = TokenMap.empty;
				otherwise_action = None}
			in
			states.(index) <- s;
			kernels := CoreSetMap.add s.kernel s.no !kernels;
			index + 1
		) i_set 0 in
		for iter_s = 0 to Array.length states - 1 do
			let s = states.(iter_s) in
			SymbolSet.iter (fun j ->
				let gotoIX = make_lr0_goto s.cores j rules in
				if not (CoreSet.is_empty gotoIX) then (
					let gotoIX2 = choose_kernel gotoIX in
					s.goto_table <- SymbolMap.add j (CoreSetMap.find gotoIX2 !kernels) s.goto_table
				)
			) all_symbols
		done;
		if debug then (
			pp_end_section f ()
		);
		(* 2, 3 *)
		if debug then pp_begin_section f "step 2, 3";
		(* 2. Apply Algorithm 4.62 to the kernel of each set of LR(0)
		 * items and grammar symbol X to determine which lookaheads
		 * are spontaneously generated for kernel items in GOTO( I, X
		 * ), and from which items in I lookaheads are propagated to
		 * kernel items in GOTO( I, X ). *)
		(* 3. Initialize a table that gives, for each kernel item in
		 * each set of items, the associated lookaheads.  Initially,
		 * each item has associated with it only those lookaheads that
		 * we determined in step(2) were generated spontaneously. *)
		for iter_s = 0 to Array.length states - 1 do
			let s = states.(iter_s) in
			CoreSet.iter (fun k ->
				let j_set = ItemSet.add {core = k; lookahead = Dummy} ItemSet.empty in
				let j_set = make_lr1_closure j_set first rules in
				ItemSet.iter (fun j ->
					let j_rule = rules.(j.core.rule_index) in
					if j.core.cursor < Array.length j_rule.elements then (
						let x = j_rule.elements.(j.core.cursor) in
						let goto_state = SymbolMap.find x s.goto_table in
						let gotoIX = states.(goto_state).kernel in
						CoreSet.iter (fun l ->
							if l.rule_index = j.core.rule_index && l.cursor = j.core.cursor + 1 then (
								if j.lookahead = Dummy then (
									(* look-ahead *)
									let pair: Propagate.elt = (goto_state, l) in
									let ps = CoreMap.find_or ~not_found:Propagate.empty k s.propagate_map in
									s.propagate_map <- CoreMap.add k (Propagate.add pair ps) s.propagate_map
								) else (
									(* internal *)
									let st = states.(goto_state) in
									let ss = CoreMap.find_or ~not_found:SymbolSet.empty l st.generate_map in
									st.generate_map <- CoreMap.add l (SymbolSet.add j.lookahead ss) st.generate_map
								)
							)
						) gotoIX
					)
				) j_set
			) s.kernel
		done;
		if debug then (
			pp_end_section f ()
		);
		(* 4 *)
		if debug then pp_begin_section f "step 4";
		(* 4. Make repeated passes over the kernel items in all sets.
		 * When we visit an item /i/, we look up the kernel items to
		 * which /i/ propagates its lookaheads, using information
		 * tabulated in step (2).  The current set of lookaheads for
		 * /i/ is added to those already associated with each of the
		 * items to which items until no more new lookaheads are
		 * propagated. *)
		let iterate = ref true in
		while !iterate do
			iterate := false;
			for iter_i = 0 to Array.length states - 1 do
				let i = states.(iter_i) in
				CoreSet.iter (fun j ->
					if CoreMap.mem j i.generate_map then (
						if CoreMap.mem j i.propagate_map then (
							let sg = CoreMap.find j i.generate_map in
							let propagate = CoreMap.find j i.propagate_map in
							Propagate.iter (fun (kf, ks) ->
								let st = states.(kf) in
								let dg = CoreMap.find_or ~not_found:SymbolSet.empty ks st.generate_map in
								let n = SymbolSet.cardinal dg in
								let dg2 = SymbolSet.union sg dg in
								st.generate_map <- CoreMap.add ks dg2 st.generate_map;
								if SymbolSet.cardinal dg2 <> n then (
									iterate := true
								)
							) propagate
						)
					)
				) i.kernel
			done
		done;
		if debug then (
			pp_end_section f ()
		);
		(* LR(1) closure *)
		if debug then pp_begin_section f "LR(1) closure";
		(* make closure by kernel lr0 collection and look-ahead *)
		for iter_i = 0 to Array.length states - 1 do
			let i = states.(iter_i) in
			CoreSet.iter (fun x ->
				let syms = CoreMap.find x i.generate_map in
				SymbolSet.iter (fun s ->
					i.items <- ItemSet.add {core = x; lookahead = s} i.items
				) syms
			) i.kernel;
			i.items <- make_lr1_closure i.items first rules
		done;
		if debug then (
			pp_end_section f ()
		);
		(* semantic-action *)
		if debug then pp_begin_section f "semantic-action";
		(* make semantic-action by J(i) *)
		for iter_i = 0 to Array.length states - 1 do
			let s = states.(iter_i) in
			(* a) if [A -> alpha . a beta,b] included by J(i) and goto(J(i),a) = J(j),
			 * action[i,a] <- "shift j" (a must be terminal symbol.) *)
			 ItemSet.iter (fun x ->
			 	let x_rule = rules.(x.core.rule_index) in
			 	if x.core.cursor < Array.length x_rule.elements then (
			 		let a = x_rule.elements.(x.core.cursor) in
			 		begin match a with
			 		| Dummy -> assert false
			 		| Nonterminal _ | Epsilon -> ()
			 		| Terminal token ->
			 			if SymbolMap.mem a s.goto_table then (
				 			let next = SymbolMap.find a s.goto_table in
				 			s.goto_table <- SymbolMap.remove a s.goto_table;
				 			(* shift *)
				 			if TokenMap.mem token s.action_table then (
				 				let (k_rule_index, k) = TokenMap.find token s.action_table in
				 				begin match k with
				 				| Shift _ -> ()
				 				| Reduce _ ->
				 					shift_reduce_conflict x_rule rules.(k_rule_index)
				 				| Accept ->
				 					shift_reduce_conflict x_rule root_rule
				 				| ErrorShiftTerminal _ | ErrorShiftNonterminal _ | ErrorReduce _ -> assert false
				 				end
							);
							let new_action = Shift next in
							s.action_table <- TokenMap.add token (x.core.rule_index, new_action) s.action_table
						)
					end
				)
			) s.items;
			(* do b) and c) at the same time. *)
			ItemSet.iter (fun x ->
				let x_rule = rules.(x.core.rule_index) in
			 	if x.core.cursor >= Array.length x_rule.elements then (
			 		(* about conflict judgement, think an accept as a kind of reduce. *)
			 		let add_action = (
			 			let token = (
			 				begin match x.lookahead with
			 				| Terminal token -> token
			 				| Nonterminal _ | Dummy | Epsilon -> assert false
			 				end
			 			) in
			 			if TokenMap.mem token s.action_table then (
			 				let (k_rule_index, k) = TokenMap.find token s.action_table in
			 				begin match k with
			 				| Shift _ ->
			 					shift_reduce_conflict rules.(k_rule_index) x_rule;
			 					false (* shift *)
			 				| Reduce _ ->
			 					if k_rule_index <> x.core.rule_index then (
			 						reduce_reduce_conflict rules.(k_rule_index) x_rule;
			 						x.core.rule_index < k_rule_index (* select by index *)
			 					) else (
			 						true
			 					)
			 				| Accept ->
			 					if x.core.rule_index = 0 then (
			 						reduce_reduce_conflict root_rule x_rule;
			 						false (* select by index *)
			 					) else (
			 						true
			 					)
			 				| ErrorShiftTerminal _ | ErrorShiftNonterminal _ | ErrorReduce _ -> assert false
			 				end
						) else (
							true
						)
					) in
					if add_action then (
						if x.core.rule_index > 0 then ( (* not root *)
							(* b) if term [A -> alpha.,a] is an element of Ji, A /= S then
							 * action[i,a] <- "reduce A -> alpha" *)
							let token = (
				 				begin match x.lookahead with
				 				| Terminal token -> token
				 				| Nonterminal _ | Dummy | Epsilon -> assert false
				 				end
							) in
							let new_action = Reduce (
								Array.length x_rule.elements, (* pop *)
								x_rule.semantic_action, (* semantic action *)
								rules.(x.core.rule_index).left (* nonterminal index *)
							) in
							s.action_table <- TokenMap.add token (x.core.rule_index, new_action) s.action_table
						) else ( (* root *)
							(* c) if term [S'->S.,$] is an element of Ji, action[i,$]<-"accept" *)
							let a = Accept in
							s.action_table <- TokenMap.add Token.eof (-1, a) s.action_table
						)
					)
				)
			) s.items;
			(* for making goto function for i, apply next rule to all non-terminal symbols.
			 * if goto(I(i),A)=I(j) then goto[i,A]=j *)
			SymbolSet.iter (fun a ->
				let gt2 = make_lr1_goto s.items a first rules in
				let gt = ItemSet.fold (fun {core = c; lookahead = _} r ->
					CoreSet.add c r
				) gt2 CoreSet.empty in
				if CoreSetMap.mem gt !kernels then (
					let next = CoreSetMap.find gt !kernels in
					s.goto_table <- SymbolMap.add a next s.goto_table
				)
			) nonterminals
		done;
		if debug then (
			pp_end_section f ()
		);
		(* error handling *)
		if error_handling then (
			if debug then pp_begin_section f "error handling";
			(* min length *)
			let min_length_of_symbol = ErrorHandling.min_length_of_symbol rules ~terminals in
			assert (SymbolSet.cardinal all_symbols = SymbolMap.fold (fun _ _ i -> succ i) min_length_of_symbol 0);
			if debug then (
				Format.fprintf f "@[<hov2>min-length:@ %a@]@."
					(pp_symbol_map ~pp_nonterminal ~pp_elt:Format.pp_print_int) min_length_of_symbol
			);
			(* super first/follow set *)
			let (super_first, super_follow) = ErrorHandling.make_super_first_and_follow ~nonterminals rules ~first ~follow in
			if debug then (
				Format.fprintf f "@[<hov2>super-first-set:@ %a@]@."
					(pp_symbol_map ~pp_nonterminal ~pp_elt:(pp_symbol_map ~pp_nonterminal ~pp_elt:Format.pp_print_int)) super_first;
				Format.fprintf f "@[<hov2>super-follow-set:@ %a@]@."
					(pp_symbol_map ~pp_nonterminal ~pp_elt:(pp_core_map ~pp_elt:(pp_symbol_set ~pp_nonterminal))) super_follow
			);
			(* same symbol set *)
			let same_symbols = ErrorHandling.make_same_symbols rules in
			if debug then (
				Format.fprintf f "@[<hov2>same-symbol-set:@ %a@]@."
					(pp_symbol_map ~pp_nonterminal ~pp_elt:(pp_symbol_set ~pp_nonterminal)) same_symbols
			);
			(* generating... *)
			ErrorHandling.generate_error_recovery f ~debug ~min_length_of_symbol
				~first ~follow ~super_first ~super_follow ~same_symbols rules states;
			if debug then (
				pp_end_section f ()
			)
		);
		(* first state *)
		if debug then pp_begin_section f "first state";
		let first = select_first_state states in
		if debug then (
			pp_end_section f ()
		);
		(* result *)
		{rules = rules;
			states = states;
			first = first;
			nonterminals = Array.of_list (SymbolSet.elements nonterminals)}
	);;
	
	let rules (t: table): rule array = (
		t.rules
	);;
	
	let states (t: table): state array = (
		t.states
	);;
	
	let start_state (t: table): int = (
		t.first
	);;
	
	let nonterminals (t: table): symbol array = (
		t.nonterminals
	);;
	
	let check (all_tokens: Token.t list) (t: table): (int list * Token.t) list = (
		let rec drop n xs = (
			if n = 0 then xs else
			match xs with _ :: xr -> drop (n - 1) xr | [] -> raise (Failure "drop")
		) in
		let result = Array.fold_left (fun result i ->
			let rec stack_loop depth init_stack result = (
				let rec check_loop tk stack path result = (
					let next_loop next stack = (
						let depth = List.length stack in
						if List.exists (fun (st, de) -> st = next && de <= depth) path then (
							if List.exists (fun (n, t) -> n = init_stack && Token.compare t tk = 0) result then (
								result
							) else (
								(init_stack, tk) :: result
							)
						) else (
							check_loop tk (next :: stack) ((next, depth) :: path) result
						)
					) in
					let (_, act) = TokenMap.find_or ~not_found:(-1, Accept) tk t.states.(List.hd stack).action_table in
					begin match act with
					| Shift _ | Accept ->
						result
					| Reduce (pop, _, nti) | ErrorReduce (pop, _, nti) ->
						if pop >= List.length stack then (
							result
						) else (
							let stack = drop pop stack in
							let next = SymbolMap.find (Nonterminal nti) t.states.(List.hd stack).goto_table in
							next_loop next stack
						)
					| ErrorShiftTerminal (_, dsi) | ErrorShiftNonterminal (_, _, _, dsi) ->
						next_loop dsi stack
					end
				) in
				let result = List.fold_left (fun result tk ->
					check_loop tk init_stack [] result
				) result all_tokens in
				if depth = 0 then result else (
					List.fold_left (fun result tk ->
						let (_, act) = TokenMap.find_or ~not_found:(-1, Accept) tk t.states.(List.hd init_stack).action_table in
						begin match act with
						| Shift dsi ->
							stack_loop (depth - 1) (dsi :: init_stack) result
						| Accept | Reduce _ | ErrorReduce _ | ErrorShiftTerminal _ | ErrorShiftNonterminal _ ->
							result
						end
					) result all_tokens
				)
			) in
			stack_loop 2 [i.no] result
		) [] t.states in
		List.sort (fun (n1, t1) (n2, t2) -> let r = Pervasives.compare n1 n2 in if r <> 0 then r else Token.compare t1 t2) result
	);;
	
	(* compaction *)
	
	module Compaction = struct
		
		module ActionMap = struct
			include Map.Make (Action);;
			let find_or ~not_found k m = (
				try find k m with Not_found -> not_found
			);;
		end;;
		
		let unify
			(actions: (int * action) TokenMap.t)
			(otherwise: (int * action) option)
			: (TokenSet.t * TokenSet.t * bool) ActionMap.t =
		(
			let default = (TokenSet.empty, TokenSet.empty, false) in
			let result_map = TokenMap.fold (fun token (_, action) result ->
				let (adding_action, adding_tokens) = (
					begin match action with
					| ErrorReduce (p, sa, ni) ->
						let new_action = Reduce (p, sa, ni) in
						let (ts, ets, ot) = ActionMap.find_or ~not_found:default new_action result in
						(new_action, (ts, TokenSet.add token ets, ot))
					| _ ->
						let (ts, ets, ot) = ActionMap.find_or ~not_found:default action result in
						(action, (TokenSet.add token ts, ets, ot))
					end
				) in
				ActionMap.add adding_action adding_tokens result
			) actions ActionMap.empty in
			begin match otherwise with
			| Some (_, action) ->
				let (adding_action, adding_tokens) = (
					begin match action with
					| ErrorReduce (p, sa, ni) ->
						let new_action = Reduce (p, sa, ni) in
						let (ts, ets, _) = ActionMap.find_or ~not_found:default new_action result_map in
						(new_action, (ts, ets, true))
					| _ ->
						let (ts, ets, _) = ActionMap.find_or ~not_found:default action result_map in
						(action, (ts, ets, true))
					end
				) in
				ActionMap.add adding_action adding_tokens result_map
			| None ->
				result_map
			end
		);;
		
		let iter
			(f: action -> (TokenSet.t * TokenSet.t * bool) -> bool -> unit)
			(map: (TokenSet.t * TokenSet.t * bool) ActionMap.t): bool =
		(
			let otherwise_case = ref None in
			let first = ActionMap.fold (fun action ((_, _, otherwise) as tss) first ->
				if otherwise then (
					otherwise_case := Some (action, tss);
					first
				) else (
					f action tss first;
					false
				)
			) map true in
			begin match !otherwise_case with
			| Some (action, tss) ->
				f action tss first;
				false
			| None ->
				true (* result means having otherwise case *)
			end
		);;
		
	end;;
	
end;;
